home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / emacs.lha / emacs-19.16 / lisp / rmailout.el < prev    next >
Lisp/Scheme  |  1993-06-18  |  7KB  |  200 lines
  1. ;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file.
  2.  
  3. ;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Code:
  25.  
  26. ;; Temporary until Emacs always has this variable.
  27. (defvar rmail-delete-after-output nil
  28.   "*Non-nil means automatically delete a message that is copied to a file.")
  29.  
  30. (defvar rmail-output-file-alist nil
  31.   "*Alist matching regexps to suggested output Rmail files.
  32. This is a list of elements of the form (REGEXP . FILENAME).")
  33.  
  34. ;;; There are functions elsewhere in Emacs that use this function; check
  35. ;;; them out before you change the calling method.
  36. (defun rmail-output-to-rmail-file (file-name &optional count)
  37.   "Append the current message to an Rmail file named FILE-NAME.
  38. If the file does not exist, ask if it should be created.
  39. If file is being visited, the message is appended to the Emacs
  40. buffer visiting that file.
  41. A prefix argument N says to output N consecutive messages
  42. starting with the current one.  Deleted messages are skipped and don't count."
  43.   (interactive
  44.    (let ((default-file
  45.        (let (answer tail)
  46.          (setq tail rmail-output-file-alist)
  47.          ;; Suggest a file based on a pattern match.
  48.          (while (and tail (not answer))
  49.            (save-excursion
  50.          (goto-char (point-min))
  51.          (if (re-search-forward (car (car tail)) nil t)
  52.              (setq answer (cdr (car tail))))
  53.          (setq tail (cdr tail))))
  54.          ;; If not suggestions, use same file as last time.
  55.          (or answer rmail-last-rmail-file))))
  56.      (list (read-file-name
  57.         (concat "Output message to Rmail file: (default "
  58.             (file-name-nondirectory default-file)
  59.             ") ")
  60.         (file-name-directory rmail-last-rmail-file)
  61.         default-file)
  62.        (prefix-numeric-value current-prefix-arg))))
  63.   (or count (setq count 1))
  64.   (setq file-name
  65.     (expand-file-name file-name
  66.               (file-name-directory rmail-last-rmail-file)))
  67.   (setq rmail-last-rmail-file file-name)
  68.   (rmail-maybe-set-message-counters)
  69.   (setq file-name (abbreviate-file-name file-name))
  70.   (or (get-file-buffer file-name)
  71.       (file-exists-p file-name)
  72.       (if (yes-or-no-p
  73.        (concat "\"" file-name "\" does not exist, create it? "))
  74.       (let ((file-buffer (create-file-buffer file-name)))
  75.         (save-excursion
  76.           (set-buffer file-buffer)
  77.           (rmail-insert-rmail-file-header)
  78.           (let ((require-final-newline nil))
  79.         (write-region (point-min) (point-max) file-name t 1)))
  80.         (kill-buffer file-buffer))
  81.     (error "Output file does not exist")))
  82.   (while (> count 0)
  83.     (let (redelete)
  84.       (unwind-protect
  85.       (progn
  86.         (save-restriction
  87.           (widen)
  88.           (if (rmail-message-deleted-p rmail-current-message)
  89.           (progn (setq redelete t)
  90.              (rmail-set-attribute "deleted" nil)))
  91.           ;; Decide whether to append to a file or to an Emacs buffer.
  92.           (save-excursion
  93.         (let ((buf (get-file-buffer file-name))
  94.               (cur (current-buffer))
  95.               (beg (1+ (rmail-msgbeg rmail-current-message)))
  96.               (end (1+ (rmail-msgend rmail-current-message))))
  97.           (if (not buf)
  98.               (append-to-file beg end file-name)
  99.             (if (eq buf (current-buffer))
  100.             (error "Can't output message to same file it's already in"))
  101.             ;; File has been visited, in buffer BUF.
  102.             (set-buffer buf)
  103.             (let ((buffer-read-only nil)
  104.               (msg (and (boundp 'rmail-current-message)
  105.                     rmail-current-message)))
  106.               ;; If MSG is non-nil, buffer is in RMAIL mode.
  107.               (if msg
  108.               (progn
  109.                 (rmail-maybe-set-message-counters)
  110.                 (widen)
  111.                 (narrow-to-region (point-max) (point-max))
  112.                 (insert-buffer-substring cur beg end)
  113.                 (goto-char (point-min))
  114.                 (widen)
  115.                 (search-backward "\n\^_")
  116.                 (narrow-to-region (point) (point-max))
  117.                 (rmail-count-new-messages t)
  118.                 (rmail-show-message msg))
  119.           ;; Output file not in rmail mode => just insert at the end.
  120.           (narrow-to-region (point-min) (1+ (buffer-size)))
  121.           (goto-char (point-max))
  122.           (insert-buffer-substring cur beg end)))))))
  123.         (rmail-set-attribute "filed" t))
  124.     (if redelete (rmail-set-attribute "deleted" t))))
  125.     (setq count (1- count))
  126.     (if rmail-delete-after-output
  127.     (rmail-delete-forward)
  128.       (if (> count 0)
  129.       (rmail-next-undeleted-message 1)))))
  130.  
  131. ;;; There are functions elsewhere in Emacs that use this function; check
  132. ;;; them out before you change the calling method.
  133. (defun rmail-output (file-name &optional count)
  134.   "Append this message to Unix mail file named FILE-NAME.
  135. A prefix argument N says to output N consecutive messages
  136. starting with the current one.  Deleted messages are skipped and don't count.
  137. When called from lisp code, N may be omitted."
  138.   (interactive
  139.    (list (read-file-name
  140.       (concat "Output message to Unix mail file"
  141.           (if rmail-last-file
  142.               (concat " (default "
  143.                   (file-name-nondirectory rmail-last-file)
  144.                   "): " )
  145.             ": "))            
  146.       (and rmail-last-file (file-name-directory rmail-last-file))
  147.       rmail-last-file)
  148.      (prefix-numeric-value current-prefix-arg)))
  149.   (or count (setq count 1))
  150.   (setq file-name
  151.     (expand-file-name file-name
  152.               (and rmail-last-file
  153.                    (file-name-directory rmail-last-file))))
  154.   (setq rmail-last-file file-name)
  155.   (while (> count 0)
  156.     (let ((rmailbuf (current-buffer))
  157.       (tembuf (get-buffer-create " rmail-output"))
  158.       (case-fold-search t))
  159.       (save-excursion
  160.     (set-buffer tembuf)
  161.     (erase-buffer)
  162.     ;; If we can do it, read a little of the file
  163.     ;; to check whether it is an RMAIL file.
  164.     ;; If it is, don't mess it up.
  165.     (and (file-readable-p file-name)
  166.          (progn (insert-file-contents file-name nil 0 20)
  167.             (looking-at "BABYL OPTIONS:\n"))
  168.          (error (save-excursion
  169.               (set-buffer rmailbuf)
  170.               (substitute-command-keys
  171.                "Use \\[rmail-output-to-rmail-file] to output to Rmail file `%s'"))
  172.             (file-name-nondirectory file-name)))
  173.     (erase-buffer)
  174.     (insert-buffer-substring rmailbuf)
  175.     (insert "\n")
  176.     (goto-char (point-min))
  177.     (insert "From "
  178.         (mail-strip-quoted-names (or (mail-fetch-field "from")
  179.                          (mail-fetch-field "really-from")
  180.                          (mail-fetch-field "sender")
  181.                          "unknown"))
  182.         " " (current-time-string) "\n")
  183.     ;; ``Quote'' "\nFrom " as "\n>From "
  184.     ;;  (note that this isn't really quoting, as there is no requirement
  185.     ;;   that "\n[>]+From " be quoted in the same transparent way.)
  186.     (while (search-forward "\nFrom " nil t)
  187.       (forward-char -5)
  188.       (insert ?>))
  189.     (append-to-file (point-min) (point-max) file-name))
  190.       (kill-buffer tembuf))
  191.     (if (equal major-mode 'rmail-mode)
  192.     (rmail-set-attribute "filed" t))
  193.     (setq count (1- count))
  194.     (if rmail-delete-after-output
  195.     (rmail-delete-forward)
  196.       (if (> count 0)
  197.       (rmail-next-undeleted-message 1)))))
  198.  
  199. ;;; rmailout.el ends here
  200.